home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / w3-sysdp.el.z / w3-sysdp.el
Encoding:
Text File  |  1998-05-21  |  26.0 KB  |  689 lines
  1. ;;; sysdep.el --- consolidate Emacs-version dependencies in one file.
  2.  
  3. ;; Copyright (c) 1995 - 1997 Ben Wing.
  4.  
  5. ;; Author: Ben Wing <wing@666.com>, William Perry <wmperry@cs.indiana.edu>
  6. ;; Keywords: lisp, tools
  7. ;; Version: 0.003
  8.  
  9. ;; The purpose of this file is to eliminate the cruftiness that
  10. ;; would otherwise be required of packages that want to run on multiple
  11. ;; versions of Emacs.  The idea is that we make it look like we're running
  12. ;; the latest version of XEmacs (currently 19.12) by emulating all the
  13. ;; missing functions.
  14.  
  15. ;; #### This file does not currently do any advising but should.
  16. ;; Unfortunately, advice.el is a hugely big package.  Is any such
  17. ;; thing as `advice-lite' possible?
  18.  
  19. ;; #### - This package is great, but its role needs to be thought out a bit
  20. ;; more.  Sysdep will not permit programs written for the old XEmacs API to
  21. ;; run on new versions of XEmacs.  Sysdep is a backward-compatibility
  22. ;; package for the latest and greatest XEmacs API.  It permits programmers
  23. ;; to use the latest XEmacs functionality and still have their programs run
  24. ;; on older versions of XEmacs...perhaps even on FSF Emacs.  It should NEVER
  25. ;; ever need to be loaded in the newest XEmacs.  It doesn't even make sense
  26. ;; to put it in the lisp/utils part of the XEmacs distribution because it's
  27. ;; real purpose is to be distributed with packages like w3 which take
  28. ;; advantage of the latest and greatest features of XEmacs but still need to
  29. ;; be run on older versions.  --Stig
  30.  
  31. ;; Any packages that wish to use this file should load it using
  32. ;; `load-library'.  It will not load itself if a version of sysdep.el
  33. ;; that is at least as recent has already been loaded, but will
  34. ;; load over an older version of sysdep.el.  It will attempt to
  35. ;; not redefine functions that have already been custom-redefined,
  36. ;; but will redefine a function if the supplied definition came from
  37. ;; an older version of sysdep.el.
  38.  
  39. ;; Packages such as w3 that wish to include this file with the package
  40. ;; should rename it to something unique, such as `w3-sysdep.el', and
  41. ;; load it with `load-library'.  That will ensure that no conflicts
  42. ;; arise if more than one package in the load path provides a version
  43. ;; of sysdep.el.  If multiple packages load sysdep.el, the most recent
  44. ;; version will end up loaded; as long as I'm careful not to
  45. ;; introduce bugs in previously working definitions, this should work
  46. ;; fine.
  47.  
  48. ;; You may well discover deficiencies in this file as you use it.
  49. ;; The preferable way of dealing with this is to send me a patch
  50. ;; to sysdep.el; that way, the collective body of knowledge gets
  51. ;; increased.
  52.  
  53. ;; IMPORTANT: leave the version string in the format X.XXX (e.g. 1.001)
  54. ;; so that string comparisons to other versions work properly.
  55.  
  56. (defconst sysdep-potential-version "0.003")
  57.  
  58. ;; this macro means: define the function, but only if either it
  59. ;; wasn't bound before, or the supplied binding comes from an older
  60. ;; version of sysdep.el.  That way, user-supplied bindings don't
  61. ;; get overridden.
  62.  
  63. ;; note: sysdep-defalias is often more useful than this function,
  64. ;; esp. since you can do load-time conditionalizing and can
  65. ;; optionally leave the function undefined. (e.g. frame functions
  66. ;; in v18.)
  67.  
  68. (defmacro sysdep-defun (function &rest everything-else)
  69.   (` (cond ((and (not (fboundp (quote (, function))))
  70.          (or
  71.           (not
  72.            (stringp (get (quote (, function)) 'sysdep-defined-this)))
  73.           (and (get (quote (, function)) 'sysdep-defined-this)
  74.                (string-lessp
  75.             (get (quote (, function)) 'sysdep-defined-this)
  76.             sysdep-potential-version))))
  77.         (put (quote (, function)) 'sysdep-defined-this
  78.          sysdep-potential-version)
  79.         (defun (, function) (,@ everything-else))))))
  80.  
  81. (defmacro sysdep-defvar (function &rest everything-else)
  82.   (` (cond ((and (not (boundp (quote (, function))))
  83.          (or 
  84.           (not
  85.            (stringp (get (quote (, function)) 'sysdep-defined-this)))
  86.           (and (get (quote (, function)) 'sysdep-defined-this)
  87.                (string-lessp
  88.             (get (quote (, function)) 'sysdep-defined-this)
  89.             sysdep-potential-version))))
  90.         (put (quote (, function)) 'sysdep-defined-this t)
  91.         (defvar (, function) (,@ everything-else))))))
  92.  
  93. (defmacro sysdep-defconst (function &rest everything-else)
  94.   (` (cond ((and (not (boundp (quote (, function))))
  95.          (or
  96.           (not
  97.            (stringp (get (quote (, function)) 'sysdep-defined-this)))
  98.           (and (get (quote (, function)) 'sysdep-defined-this)
  99.                (string-lessp
  100.             (get (quote (, function)) 'sysdep-defined-this)
  101.             sysdep-potential-version))))
  102.         (put (quote (, function)) 'sysdep-defined-this t)
  103.         (defconst (, function) (,@ everything-else))))))
  104.  
  105. ;; similar for fset and defalias.  No need to quote as the argument
  106. ;; is already quoted.
  107.  
  108. (defmacro sysdep-fset (function def)
  109.   (` (cond ((and (not (fboundp (, function)))
  110.          (or (not (stringp
  111.                (get (, function) 'sysdep-defined-this)))
  112.              (and (get (, function) 'sysdep-defined-this)
  113.               (string-lessp
  114.                (get (, function) 'sysdep-defined-this)
  115.                sysdep-potential-version)))
  116.          (, def))
  117.         (put (, function) 'sysdep-defined-this t)
  118.         (fset (, function) (, def))))))
  119.  
  120. (defmacro sysdep-defalias (function def)
  121.   (` (cond ((and (not (fboundp (, function)))
  122.          (or (not (stringp
  123.                (get (, function) 'sysdep-defined-this)))
  124.              (and (get (, function) 'sysdep-defined-this)
  125.               (string-lessp
  126.                (get (, function) 'sysdep-defined-this)
  127.                sysdep-potential-version)))
  128.          (, def)
  129.          (or (listp (, def))
  130.              (and (symbolp (, def))
  131.               (fboundp (, def)))))
  132.         (put (, function) 'sysdep-defined-this t)
  133.         (defalias (, function) (, def))))))
  134.  
  135. ;; bootstrapping: defalias and define-function don't exist
  136. ;; in older versions of lemacs
  137.  
  138. (sysdep-fset 'defalias 'fset)
  139. (sysdep-defalias 'define-function 'defalias)
  140.  
  141. ;; useful ways of determining what version is running
  142. ;; emacs-major-version and emacs-minor-version are
  143. ;; already defined in recent versions of FSF Emacs and XEmacs
  144.  
  145. (sysdep-defconst emacs-major-version
  146.          ;; will string-match ever fail?  If so, assume 19.0.
  147.          ;; (should we assume 18.something?)
  148.          (if (string-match "^[0-9]+" emacs-version)
  149.              (string-to-int
  150.               (substring emacs-version
  151.                  (match-beginning 0) (match-end 0)))
  152.            19))
  153.  
  154. (sysdep-defconst emacs-minor-version
  155.          (if (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version)
  156.              (string-to-int
  157.               (substring emacs-version
  158.                  (match-beginning 1) (match-end 1)))
  159.            0))
  160.  
  161. (sysdep-defconst sysdep-running-xemacs
  162.          (or (string-match "Lucid" emacs-version)
  163.              (string-match "XEmacs" emacs-version)))
  164.  
  165. (sysdep-defconst window-system nil)
  166. (sysdep-defconst window-system-version 0)
  167.  
  168. (sysdep-defvar list-buffers-directory nil)
  169. (sysdep-defvar x-library-search-path (`
  170.                       ("/usr/X11R6/lib/X11/"
  171.                        "/usr/X11R5/lib/X11/"
  172.                        "/usr/lib/X11R6/X11/"
  173.                        "/usr/lib/X11R5/X11/"
  174.                        "/usr/local/X11R6/lib/X11/"
  175.                        "/usr/local/X11R5/lib/X11/"
  176.                        "/usr/local/lib/X11R6/X11/"
  177.                        "/usr/local/lib/X11R5/X11/"
  178.                        "/usr/X11/lib/X11/"
  179.                        "/usr/lib/X11/"
  180.                        "/usr/local/lib/X11/"
  181.                        "/usr/X386/lib/X11/"
  182.                        "/usr/x386/lib/X11/"
  183.                        "/usr/XFree86/lib/X11/"
  184.                        "/usr/unsupported/lib/X11/"
  185.                        "/usr/athena/lib/X11/"
  186.                        "/usr/local/x11r5/lib/X11/"
  187.                        "/usr/lpp/Xamples/lib/X11/"
  188.                        "/usr/openwin/lib/X11/"
  189.                        "/usr/openwin/share/lib/X11/"
  190.                        (, data-directory)
  191.                        )
  192.                       )
  193.   "Search path used for X11 libraries.")
  194.  
  195. ;; frame-related stuff.
  196.  
  197. (sysdep-defalias 'buffer-dedicated-frame 'buffer-dedicated-screen)
  198. (sysdep-defalias 'deiconify-frame
  199.   (cond ((fboundp 'deiconify-screen) 'deiconify-screen)
  200.     ;; make-frame-visible will be defined as necessary
  201.     (t 'make-frame-visible)))
  202. (sysdep-defalias 'delete-frame 'delete-screen)
  203. (sysdep-defalias 'event-frame 'event-screen)
  204. (sysdep-defalias 'event-glyph-extent 'event-glyph)
  205. (sysdep-defalias 'find-file-other-frame 'find-file-other-screen)
  206. (sysdep-defalias 'find-file-read-only-other-frame
  207.   'find-file-read-only-other-screen)
  208. (sysdep-defalias 'frame-height 'screen-height)
  209. (sysdep-defalias 'frame-iconified-p 'screen-iconified-p)
  210. (sysdep-defalias 'frame-left-margin-width 'screen-left-margin-width)
  211. (sysdep-defalias 'frame-list 'screen-list)
  212. (sysdep-defalias 'frame-live-p
  213.   (cond ((fboundp 'screen-live-p) 'screen-live-p)
  214.     ((fboundp 'live-screen-p) 'live-screen-p)
  215.     ;; #### not sure if this is correct (this is for Epoch)
  216.     ;; but gnuserv.el uses it this way
  217.     ((fboundp 'screenp) 'screenp)))
  218. (sysdep-defalias 'frame-name 'screen-name)
  219. (sysdep-defalias 'frame-parameters 'screen-parameters)
  220. (sysdep-defalias 'frame-pixel-height 'screen-pixel-height)
  221. (sysdep-defalias 'frame-pixel-width 'screen-pixel-width)
  222. (sysdep-defalias 'frame-right-margin-width 'screen-right-margin-width)
  223. (sysdep-defalias 'frame-root-window 'screen-root-window)
  224. (sysdep-defalias 'frame-selected-window 'screen-selected-window)
  225. (sysdep-defalias 'frame-totally-visible-p 'screen-totally-visible-p)
  226. (sysdep-defalias 'frame-visible-p 'screen-visible-p)
  227. (sysdep-defalias 'frame-width 'screen-width)
  228. (sysdep-defalias 'framep 'screenp)
  229. (sysdep-defalias 'get-frame-for-buffer 'get-screen-for-buffer)
  230. (sysdep-defalias 'get-frame-for-buffer-noselect 'get-screen-for-buffer-noselect)
  231. (sysdep-defalias 'get-other-frame 'get-other-screen)
  232. (sysdep-defalias 'iconify-frame 'iconify-screen)
  233. (sysdep-defalias 'lower-frame 'lower-screen)
  234. (sysdep-defalias 'mail-other-frame 'mail-other-screen)
  235.  
  236. (sysdep-defalias 'make-frame
  237.   (cond ((fboundp 'make-screen)
  238.      (function (lambda (&optional parameters device)
  239.              (make-screen parameters))))
  240.     ((fboundp 'x-create-screen)
  241.      (function (lambda (&optional parameters device)
  242.              (x-create-screen parameters))))))
  243.  
  244. (sysdep-defalias 'make-frame-invisible 'make-screen-invisible)
  245. (sysdep-defalias 'make-frame-visible
  246.   (cond ((fboundp 'make-screen-visible) 'make-screen-visible)
  247.     ((fboundp 'mapraised-screen) 'mapraised-screen)
  248.     ((fboundp 'x-remap-window)
  249.      (lambda (&optional x)
  250.        (x-remap-window)
  251.        (accept-process-output)))))
  252. (sysdep-defalias 'modify-frame-parameters 'modify-screen-parameters)
  253. (sysdep-defalias 'new-frame 'new-screen)
  254. (sysdep-defalias 'next-frame 'next-screen)
  255. (sysdep-defalias 'next-multiframe-window 'next-multiscreen-window)
  256. (sysdep-defalias 'other-frame 'other-screen)
  257. (sysdep-defalias 'previous-frame 'previous-screen)
  258. (sysdep-defalias 'previous-multiframe-window 'previous-multiscreen-window)
  259. (sysdep-defalias 'raise-frame
  260.   (cond ((fboundp 'raise-screen) 'raise-screen)
  261.     ((fboundp 'mapraise-screen) 'mapraise-screen)))
  262. (sysdep-defalias 'redraw-frame 'redraw-screen)
  263. (sysdep-defalias 'select-frame 'select-screen)
  264. (sysdep-defalias 'selected-frame 'selected-screen)
  265. (sysdep-defalias 'set-buffer-dedicated-frame 'set-buffer-dedicated-screen)
  266. (sysdep-defalias 'set-frame-height 'set-screen-height)
  267. (sysdep-defalias 'set-frame-left-margin-width 'set-screen-left-margin-width)
  268. (sysdep-defalias 'set-frame-position 'set-screen-position)
  269. (sysdep-defalias 'set-frame-right-margin-width 'set-screen-right-margin-width)
  270. (sysdep-defalias 'set-frame-size 'set-screen-size)
  271. (sysdep-defalias 'set-frame-width 'set-screen-width)
  272. (sysdep-defalias 'show-temp-buffer-in-current-frame 'show-temp-buffer-in-current-screen)
  273. (sysdep-defalias 'switch-to-buffer-other-frame 'switch-to-buffer-other-screen)
  274. (sysdep-defalias 'visible-frame-list 'visible-screen-list)
  275. (sysdep-defalias 'window-frame 'window-screen)
  276. (sysdep-defalias 'x-create-frame 'x-create-screen)
  277. (sysdep-defalias 'x-set-frame-icon-pixmap 'x-set-screen-icon-pixmap)
  278. (sysdep-defalias 'x-set-frame-pointer 'x-set-screen-pointer)
  279. (sysdep-defalias 'x-display-color-p 'x-color-display-p)
  280. (sysdep-defalias 'x-display-grayscale-p 'x-grayscale-display-p)
  281. (sysdep-defalias 'menu-event-p 'misc-user-event-p)
  282.  
  283. (sysdep-defun event-point (event)
  284.   (let ((posn (event-end event)))
  285.     (if posn 
  286.      (posn-point posn))))
  287.  
  288. ;; WMP - commenting these out so that Emacs 19 doesn't get screwed by them.
  289. ;; In particular, this makes the 'custom' package blow up quite well.
  290. ;;(sysdep-defun add-submenu (menu-path submenu &optional before)
  291. ;;  "Add a menu to the menubar or one of its submenus.
  292. ;;If the named menu exists already, it is changed.
  293. ;;MENU-PATH identifies the menu under which the new menu should be inserted.
  294. ;; It is a list of strings; for example, (\"File\") names the top-level \"File\"
  295. ;; menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
  296. ;; If MENU-PATH is nil, then the menu will be added to the menubar itself.
  297. ;;SUBMENU is the new menu to add.
  298. ;; See the documentation of `current-menubar' for the syntax.
  299. ;;BEFORE, if provided, is the name of a menu before which this menu should
  300. ;; be added, if this menu is not on its parent already.  If the menu is already
  301. ;; present, it will not be moved."
  302. ;;  (add-menu menu-path (car submenu) (cdr submenu) before))
  303.  
  304. ;;(sysdep-defun add-menu-button (menu-path menu-leaf &optional before)
  305. ;;  "Add a menu item to some menu, creating the menu first if necessary.
  306. ;;If the named item exists already, it is changed.
  307. ;;MENU-PATH identifies the menu under which the new menu item should be inserted.
  308. ;; It is a list of strings; for example, (\"File\") names the top-level \"File\"
  309. ;; menu.  (\"File\" \"Foo\") names a hypothetical submenu of \"File\".
  310. ;;MENU-LEAF is a menubar leaf node.  See the documentation of `current-menubar'.
  311. ;;BEFORE, if provided, is the name of a menu item before which this item should
  312. ;; be added, if this item is not on the menu already.  If the item is already
  313. ;; present, it will not be moved."
  314. ;; (add-menu-item menu-path (aref menu-leaf 0) (aref menu-leaf 1)
  315. ;;        (aref menu-leaf 2) before))
  316.  
  317. (sysdep-defun make-glyph (&optional spec-list)
  318.   (if (and spec-list (cdr-safe (assq 'x spec-list)))
  319.       (make-pixmap (cdr-safe (assq 'x spec-list)))))
  320.  
  321. (sysdep-defalias 'face-list 'list-faces)
  322.  
  323. (sysdep-defun set-keymap-parent (keymap new-parent)
  324.   (let ((tail keymap))
  325.     (while (and tail (cdr tail) (not (eq (car (cdr tail)) 'keymap)))
  326.       (setq tail (cdr tail)))
  327.     (if tail
  328.     (setcdr tail new-parent))))
  329.  
  330. ;; Property list functions
  331. ;;
  332. (sysdep-defun plist-put (plist prop val)
  333.   "Change value in PLIST of PROP to VAL.
  334. PLIST is a property list, which is a list of the form
  335. (PROP1 VALUE1 PROP2 VALUE2 ...).  PROP is a symbol and VAL is any object.
  336. If PROP is already a property on the list, its value is set to VAL,
  337. otherwise the new PROP VAL pair is added.  The new plist is returned;
  338. use `(setq x (plist-put x prop val))' to be sure to use the new value.
  339. The PLIST is modified by side effects."
  340.   (let ((node (memq prop plist)))
  341.     (if node
  342.     (setcar (cdr node) val)
  343.       (setq plist (cons prop (cons val plist))))
  344.     plist))
  345.  
  346. (sysdep-defun plist-get (plist prop)
  347.   "Extract a value from a property list.
  348. PLIST is a property list, which is a list of the form
  349. (PROP1 VALUE1 PROP2 VALUE2...).  This function returns the value
  350. corresponding to the given PROP, or nil if PROP is not
  351. one of the properties on the list."
  352.   (while (and plist (not (eq (car plist) prop)))
  353.     (setq plist (cdr (cdr plist))))
  354.   (and plist (car (cdr plist))))
  355.  
  356. ;; Extent stuff
  357. (sysdep-fset 'delete-extent 'delete-overlay)
  358. (sysdep-fset 'extent-end-position 'overlay-end)
  359. (sysdep-fset 'extent-start-position 'overlay-start)
  360. (sysdep-fset 'set-extent-endpoints 'move-overlay)
  361. (sysdep-fset 'set-extent-property 'overlay-put)
  362. (sysdep-fset 'make-extent 'make-overlay)
  363.  
  364. (sysdep-defun extent-property (extent property &optional default)
  365.   (or (overlay-get extent property) default))
  366.  
  367. (sysdep-defun extent-at (pos &optional object property before at-flag)
  368.   (let ((tmp (overlays-at (point)))
  369.     ovls)
  370.     (if property
  371.     (while tmp
  372.       (if (extent-property (car tmp) property)
  373.           (setq ovls (cons (car tmp) ovls)))
  374.       (setq tmp (cdr tmp)))
  375.       (setq ovls tmp
  376.         tmp nil))
  377.     (car-safe
  378.      (sort ovls
  379.        (function
  380.         (lambda (a b)
  381.           (< (- (extent-end-position a) (extent-start-position a))
  382.          (- (extent-end-position b) (extent-start-position b)))))))))
  383.  
  384. (sysdep-defun overlays-in (beg end)
  385.   "Return a list of the overlays that overlap the region BEG ... END.
  386. Overlap means that at least one character is contained within the overlay
  387. and also contained within the specified region.
  388. Empty overlays are included in the result if they are located at BEG
  389. or between BEG and END."
  390.   (let ((ovls (overlay-lists))
  391.     tmp retval)
  392.     (if (< end beg)
  393.     (setq tmp end
  394.           end beg
  395.           beg tmp))
  396.     (setq ovls (nconc (car ovls) (cdr ovls)))
  397.     (while ovls
  398.       (setq tmp (car ovls)
  399.         ovls (cdr ovls))
  400.       (if (or (and (<= (overlay-start tmp) end)
  401.            (>= (overlay-start tmp) beg))
  402.           (and (<= (overlay-end tmp) end)
  403.            (>= (overlay-end tmp) beg)))
  404.       (setq retval (cons tmp retval))))
  405.     retval))
  406.  
  407. (sysdep-defun map-extents (function &optional object from to
  408.                     maparg flags property value)
  409.   (let ((tmp (overlays-in (or from (point-min))
  410.               (or to (point-max))))
  411.     ovls)
  412.     (if property
  413.     (while tmp
  414.       (if (extent-property (car tmp) property)
  415.           (setq ovls (cons (car tmp) ovls)))
  416.       (setq tmp (cdr tmp)))
  417.       (setq ovls tmp
  418.         tmp nil))
  419.     (catch 'done
  420.       (while ovls
  421.     (setq tmp (funcall function (car ovls) maparg)
  422.           ovls (cdr ovls))
  423.     (if tmp
  424.         (throw 'done tmp))))))
  425.  
  426. ;; misc
  427. (sysdep-fset 'make-local-hook 'make-local-variable)
  428.  
  429. (sysdep-defun buffer-substring-no-properties (beg end)
  430.   "Return the text from BEG to END, without text properties, as a string."
  431.   (format "%s" (buffer-substring beg end)))
  432.   
  433. (sysdep-defun symbol-value-in-buffer (symbol buffer &optional unbound-value)
  434.   "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound."
  435.   (save-excursion
  436.     (set-buffer buffer)
  437.     (if (not (boundp symbol))
  438.     unbound-value
  439.       (symbol-value symbol))))
  440.  
  441. (sysdep-defun insert-file-contents-literally
  442.   (file &optional visit beg end replace)
  443.   "Like `insert-file-contents', q.v., but only reads in the file.
  444. A buffer may be modified in several ways after reading into the buffer due
  445. to advanced Emacs features, such as file-name-handlers, format decoding,
  446. find-file-hooks, etc.
  447.   This function ensures that none of these modifications will take place."
  448.   (let ((file-name-handler-alist nil)
  449.     (find-file-hooks nil))
  450.     (insert-file-contents file visit beg end replace)))
  451.  
  452. (sysdep-defun alist-to-plist (alist)
  453.   "Convert association list ALIST into the equivalent property-list form.
  454. The plist is returned.  This converts from
  455.  
  456. \((a . 1) (b . 2) (c . 3))
  457.  
  458. into
  459.  
  460. \(a 1 b 2 c 3)
  461.  
  462. The original alist is not modified.  See also `destructive-alist-to-plist'."
  463.   (let (plist)
  464.     (while alist
  465.       (let ((el (car alist)))
  466.     (setq plist (cons (cdr el) (cons (car el) plist))))
  467.       (setq alist (cdr alist)))
  468.     (nreverse plist)))
  469.  
  470. (sysdep-defun add-minor-mode (toggle name &optional keymap after toggle-fun)
  471.   "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
  472. TOGGLE is a symbol which is used as the variable which toggle the minor mode,
  473. NAME is the name that should appear in the modeline (it should be a string
  474. beginning with a space), KEYMAP is a keymap to make active when the minor
  475. mode is active, and AFTER is the toggling symbol used for another minor
  476. mode.  If AFTER is non-nil, then it is used to position the new mode in the
  477. minor-mode alists.  TOGGLE-FUN specifies an interactive function that
  478. is called to toggle the mode on and off; this affects what appens when
  479. button2 is pressed on the mode, and when button3 is pressed somewhere
  480. in the list of modes.  If TOGGLE-FUN is nil and TOGGLE names an
  481. interactive function, TOGGLE is used as the toggle function.
  482.  
  483. Example:  (add-minor-mode 'view-minor-mode \" View\" view-mode-map)"
  484.   (if (not (assq toggle minor-mode-alist))
  485.       (setq minor-mode-alist (cons (list toggle name) minor-mode-alist)))
  486.   (if (and keymap (not (assq toggle minor-mode-map-alist)))
  487.       (setq minor-mode-map-alist (cons (cons toggle keymap)
  488.                        minor-mode-map-alist))))
  489.  
  490. (sysdep-defvar x-font-regexp-foundry-and-family
  491.   (let ((-         "[-?]")
  492.     (foundry        "[^-]+")
  493.     (family         "[^-]+")
  494.     )
  495.     (concat "\\`[-?*]" foundry - "\\(" family "\\)" -)))
  496.  
  497. (sysdep-defun match-string (num &optional string)
  498.   "Return string of text matched by last search.
  499. NUM specifies which parenthesized expression in the last regexp.
  500.  Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
  501. Zero means the entire text matched by the whole regexp or whole string.
  502. STRING should be given if the last search was by `string-match' on STRING."
  503.   (if (match-beginning num)
  504.       (if string
  505.       (substring string (match-beginning num) (match-end num))
  506.     (buffer-substring (match-beginning num) (match-end num)))))
  507.  
  508. (sysdep-defun add-hook (hook-var function &optional at-end)
  509.   "Add a function to a hook.
  510. First argument HOOK-VAR (a symbol) is the name of a hook, second
  511.  argument FUNCTION is the function to add.
  512. Third (optional) argument AT-END means to add the function at the end
  513.  of the hook list instead of the beginning.  If the function is already
  514.  present, this has no effect.
  515. Returns nil if FUNCTION was already present in HOOK-VAR, else new
  516.  value of HOOK-VAR."
  517.       (if (not (boundp hook-var)) (set hook-var nil))
  518.       (let ((old (symbol-value hook-var)))
  519.     (if (or (not (listp old)) (eq (car old) 'lambda))
  520.         (setq old (list old)))
  521.     (if (member function old)
  522.         nil
  523.       (set hook-var
  524.            (if at-end
  525.            (append old (list function)) ; don't nconc
  526.          (cons function old))))))
  527.  
  528. (sysdep-defalias 'valid-color-name-p
  529.   (cond
  530.    ((fboundp 'x-valid-color-name-p)    ; XEmacs/Lucid
  531.     'x-valid-color-name-p)
  532.    ((and window-system
  533.      (fboundp 'color-defined-p))    ; NS/Emacs 19
  534.     'color-defined-p)
  535.    ((and window-system
  536.      (fboundp 'pm-color-defined-p))
  537.     'pm-color-defined-p)
  538.    ((and window-system
  539.      (fboundp 'x-color-defined-p))    ; Emacs 19
  540.     'x-color-defined-p)
  541.    ((fboundp 'get-color)        ; Epoch
  542.     (function (lambda (color)
  543.         (let ((x (get-color color)))
  544.           (if x
  545.               (setq x (progn
  546.                 (free-color x)
  547.                 t)))
  548.           x))))
  549.    (t 'identity)))            ; All others
  550.  
  551. ;; Misc.
  552. ;; NT doesn't have make-symbolic-link
  553. (sysdep-defalias 'make-symbolic-link 'copy-file)
  554. (sysdep-defalias 'insert-and-inherit 'insert)
  555.  
  556. (sysdep-defun run-hook-with-args-until-success (hook &rest args)
  557.   "Run HOOK with the specified arguments ARGS.
  558. HOOK should be a symbol, a hook variable.  Its value should
  559. be a list of functions.  We call those functions, one by one,
  560. passing arguments ARGS to each of them, until one of them
  561. returns a non-nil value.  Then we return that value.
  562. If all the functions return nil, we return nil."
  563.   (let ((rval nil)
  564.     (todo (and (boundp hook) (symbol-value hook)))
  565.     (global (and (boundp hook) (default-value hook)))
  566.     (cur nil))
  567.     (while (and (setq cur (car todo)) (not rval))
  568.       (setq todo (cdr todo))
  569.       (if (eq cur t)
  570.       (if global
  571.           (setq todo (append global todo)))
  572.     (setq rval (apply cur args))))))
  573.  
  574. (sysdep-defun split-string (string pattern)
  575.   "Return a list of substrings of STRING which are separated by PATTERN."
  576.   (let (parts (start 0))
  577.     (while (string-match pattern string start)
  578.       (setq parts (cons (substring string start (match-beginning 0)) parts)
  579.         start (match-end 0)))
  580.     (nreverse (cons (substring string start) parts))
  581.     ))
  582.  
  583. (sysdep-defun member (elt list)
  584.   (while (and list (not (equal elt (car list))))
  585.     (setq list (cdr list)))
  586.   list)
  587.  
  588. (sysdep-defun rassoc (key list)
  589.   (let ((found nil))
  590.     (while (and list (not found))
  591.       (if (equal (cdr (car list)) key) (setq found (car list)))
  592.       (setq list (cdr list)))
  593.     found))
  594.  
  595. (sysdep-defun display-error (error-object stream)
  596.   "Display `error-object' on `stream' in a user-friendly way."
  597.   (funcall (or (let ((type (car-safe error-object)))
  598.          (catch 'error
  599.            (and (consp error-object)
  600.             (symbolp type)
  601.             ;;(stringp (get type 'error-message))
  602.             (consp (get type 'error-conditions))
  603.             (let ((tail (cdr error-object)))
  604.               (while (not (null tail))
  605.                 (if (consp tail)
  606.                 (setq tail (cdr tail))
  607.                   (throw 'error nil)))
  608.               t)
  609.             ;; (check-type condition condition)
  610.             (get type 'error-conditions)
  611.             ;; Search class hierarchy
  612.             (let ((tail (get type 'error-conditions)))
  613.               (while (not (null tail))
  614.                 (cond ((not (and (consp tail)
  615.                          (symbolp (car tail))))
  616.                    (throw 'error nil))
  617.                   ((get (car tail) 'display-error)
  618.                    (throw 'error (get (car tail)
  619.                               'display-error)))
  620.                   (t
  621.                    (setq tail (cdr tail)))))
  622.               ;; Default method
  623.               (function
  624.                (lambda (error-object stream)
  625.                  (let ((type (car error-object))
  626.                    (tail (cdr error-object))
  627.                    (first t))
  628.                    (if (eq type 'error)
  629.                    (progn (princ (car tail) stream)
  630.                       (setq tail (cdr tail)))
  631.                  (princ (or (get type 'error-message) type)
  632.                     stream))
  633.                    (while tail
  634.                  (princ (if first ": " ", ") stream)
  635.                  (prin1 (car tail) stream)
  636.                  (setq tail (cdr tail)
  637.                        first nil)))))))))
  638.            (function
  639.         (lambda (error-object stream)
  640.           (princ "Peculiar error " stream)
  641.           (prin1 error-object stream))))
  642.        error-object stream))
  643.  
  644. (sysdep-defun decode-time (&optional specified-time)
  645.   (let* ((date (current-time-string specified-time))
  646.      (dateinfo (and date (timezone-parse-date date)))
  647.      (timeinfo (and dateinfo (timezone-parse-time (aref dateinfo 3)))))
  648.     (list (aref timeinfo 2) (aref timeinfo 1)
  649.       (aref timeinfo 0) (aref dateinfo 2)
  650.       (aref dateinfo 1) (aref dateinfo 0)
  651.       "unknown" nil 0)))
  652.  
  653. (sysdep-defun find-face (face)
  654.   (car-safe (memq face (face-list))))
  655.  
  656. (sysdep-defun set-marker-insertion-type (marker type)
  657.   "Set the insertion-type of MARKER to TYPE.
  658. If TYPE is t, it means the marker advances when you insert text at it.
  659. If TYPE is nil, it means the marker stays behind when you insert text at it."
  660.   nil)
  661.  
  662. ;; window functions
  663.  
  664. ;; not defined in v18
  665. (sysdep-defun eval-buffer (bufname &optional printflag)
  666.   (interactive)
  667.   (save-excursion
  668.     (set-buffer bufname)
  669.     (eval-current-buffer)))
  670.  
  671. (sysdep-defun window-minibuffer-p (window)
  672.   "Returns non-nil if WINDOW is a minibuffer window."
  673.   (eq window (minibuffer-window)))
  674.  
  675. (sysdep-defun window-live-p (window)
  676.   "Returns t if OBJ is a window which is currently visible."
  677.   (and (windowp window)
  678.        (window-point window)))
  679.  
  680. (provide 'w3-sysdp)
  681. ;;; sysdep.el ends here
  682.  
  683. ;;;(sysdep.el) Local Variables:
  684. ;;;(sysdep.el) eval: (put 'sysdep-defun 'lisp-indent-function 'defun)
  685. ;;;(sysdep.el) eval: (put 'sysdep-defalias 'lisp-indent-function 'defun)
  686. ;;;(sysdep.el) eval: (put 'sysdep-defconst 'lisp-indent-function 'defun)
  687. ;;;(sysdep.el) eval: (put 'sysdep-defvar 'lisp-indent-function 'defun)
  688. ;;;(sysdep.el) End:
  689.